home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Internet Tools 1993 July / Internet Tools.iso / RockRidge / mail / vm / vm-5.33beta / vm-digest.el < prev    next >
Encoding:
Text File  |  1991-04-06  |  7.3 KB  |  195 lines
  1. ;;; Support code for RFC934 digests
  2. ;;; Copyright (C) 1989, 1990 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (defun vm-rfc934-char-stuff-region (start end)
  19.   (setq end (vm-marker end))
  20.   (save-excursion
  21.     (goto-char start)
  22.     (while (and (< (point) end) (re-search-forward "^-" end t))
  23.       (replace-match "- -" t t)))
  24.   (set-marker end nil))
  25.  
  26. (defun vm-rfc934-char-unstuff-region (start end)
  27.   (setq end (vm-marker end))
  28.   (save-excursion
  29.     (goto-char start)
  30.     (while (and (< (point) end) (re-search-forward "^- "  end t))
  31.       (replace-match "" t t)
  32.       (forward-char)))
  33.   (set-marker end nil))
  34.  
  35. (defun vm-digestify-region (start end)
  36.   (setq end (vm-marker end))
  37.   (let ((separator-regexp (if (eq vm-folder-type 'mmdf)
  38.                   "\n+\001\001\001\001\n\001\001\001\001"
  39.                 "\n+\nFrom .*")))
  40.     (save-excursion
  41.       (vm-rfc934-char-stuff-region start end)
  42.       (goto-char start)
  43.       (insert-before-markers "------- Start of digest -------\n")
  44.       (delete-region (point) (progn (forward-line) (point)))
  45.       (while (re-search-forward separator-regexp end t)
  46.     (replace-match "\n\n------------------------------\n" t nil))
  47.       (goto-char end)
  48.       (if (eq vm-folder-type 'mmdf)
  49.       (delete-region (point) (progn (forward-line -1) (point))))
  50.       (insert-before-markers "------- End of digest -------\n")))
  51.   (set-marker end nil))
  52.  
  53. (defun vm-burst-digest (&optional grotty-digest)
  54.   "Burst the current message (a digest) into its individual messages.
  55. The digest's messages are assimilated into the folder as new mail would be,
  56. e.g. message grouping takes place and if you're not reading a message
  57. you will be moved to the first new or unread message.
  58.  
  59. By default VM expects digests to be in the standard RFC 934 format.
  60. A prefix will inveigle VM into coping with other digest formats,
  61. with mixed results."
  62.   (interactive "P")
  63.   (vm-follow-summary-cursor)
  64.   (vm-select-folder-buffer)
  65.   (vm-check-for-killed-summary)
  66.   (vm-error-if-virtual-folder)
  67.   (vm-error-if-folder-read-only)
  68.   (vm-error-if-folder-empty)
  69.   (message "Bursting %sdigest..." (if grotty-digest "(possible grotty) " ""))
  70.   (let ((inhibit-quit t) start end reg-start leader trailer error-data
  71.     (reg-end (vm-marker nil))
  72.     (text-start (vm-marker nil))
  73.     (buffer-read-only)
  74.     (old-buffer-modified-p (buffer-modified-p))
  75.     (m (car vm-message-pointer)))
  76.     (save-excursion
  77.       (vm-save-restriction
  78.        (condition-case error-data
  79.        (progn
  80.          (widen)
  81.          (goto-char (point-max))
  82.          (setq start (point))
  83.          (insert-buffer-substring (current-buffer)
  84.                       (vm-text-of (car vm-message-pointer))
  85.                       (vm-text-end-of
  86.                        (car vm-message-pointer)))
  87.          (if (not
  88.           (re-search-backward "\\(^-[^ ].*\n+\\|^-\n+\\)+" start t))
  89.          (error "final message separator not found")
  90.            (setq end (point-marker))
  91.            ;; Reverse searchs are funky.  The above expression simply
  92.            ;; will not match  more than one message separator despite
  93.            ;; the "1 or more" directive at the end.
  94.            ;; This will have to suffice.
  95.            (while
  96.            (and
  97.             (save-excursion
  98.               (re-search-backward "\\(^-[^ ].*\n+\\|^-\n+\\)+" start t)
  99.               (= end (match-end 0))))
  100.          (set-marker end (match-beginning 0))
  101.          (goto-char end))
  102.            (skip-chars-backward "\n")
  103.            (set-marker end (point))
  104.            (delete-region end (point-max)))
  105.          (goto-char start)
  106.          (if (not (re-search-forward "^-[^ ]" end t))
  107.          (error "first message separator not found")
  108.            (delete-region start (match-beginning 0)))
  109.          ;; Now that we know that the digest has the basics covered
  110.          ;; try to detect and fix any bogus message separators,
  111.          ;; if the user requested it.
  112.          (and grotty-digest (vm-fix-grotty-digest start (point-max)))
  113.          ;; Concoct suitable separator strings for the future messages.
  114.          (if (eq vm-folder-type 'mmdf)
  115.          (setq leader "\001\001\001\001\n"
  116.                trailer "\n\001\001\001\001\n")
  117.            (setq leader (concat "From " (vm-from-of m) " "
  118.                     (current-time-string) "\n")
  119.              trailer "\n\n"))
  120.          (goto-char start)
  121.          (while (re-search-forward
  122.              "\\(\\(\n+\\)\\|\\(^\\)\\)\\(-[^ ].*\n+\\|-\n+\\)+"
  123.              end 0)
  124.            ;; delete message separator
  125.            (replace-match "" t t)
  126.            ;; stuff separator
  127.            (if (match-beginning 2)
  128.            (insert trailer))
  129.            (insert leader)
  130.            ;; Delete attribute headers so message will appear
  131.            ;; brand new to the user
  132.            (setq reg-start (point))
  133.            (save-excursion
  134.          (search-forward "\n\n" nil 0)
  135.          (set-marker text-start (point)))
  136.            (while (re-search-forward vm-attributes-header-regexp
  137.                      text-start t)
  138.          (delete-region (match-beginning 0) (match-end 0)))
  139.            (if vm-berkeley-mail-compatibility
  140.            (progn
  141.              (goto-char reg-start)
  142.              (while (re-search-forward vm-berkeley-mail-status-header-regexp
  143.                         text-start t)
  144.              (delete-region (match-beginning 0) (match-end 0)))))
  145.            ;; find end of message separator and unstuff the message
  146.            (goto-char reg-start)
  147.            (set-marker reg-end (if (re-search-forward "\n+-[^ ]" end 0)
  148.                        (match-beginning 0)
  149.                      (point)))
  150.            (vm-rfc934-char-unstuff-region reg-start reg-end)
  151.            (goto-char reg-end))
  152.          (goto-char end)
  153.          (insert trailer)
  154.          (set-marker end nil)
  155.          (set-marker reg-end nil)
  156.          (vm-clear-modification-flag-undos)
  157.          (vm-set-buffer-modified-p (buffer-modified-p))
  158.          (and vm-delete-after-bursting (vm-delete-message 1)))
  159.      (error (and start (delete-region start (point-max)))
  160.         (set-buffer-modified-p old-buffer-modified-p)
  161.         (if (memq (car error-data)
  162.               '(file-supersession buffer-file-locked))
  163.             (signal (car error-data) (cdr error-data)))
  164.         (error "Malformed digest")))))
  165.     (if (vm-assimilate-new-messages)
  166.     (progn
  167.       (vm-emit-totals-blurb)
  168.       (or (vm-thoughtfully-select-message)
  169.           (vm-update-summary-and-mode-line))))))
  170.  
  171. ;; This is a kludge.
  172. ;; We try to accomodate some of the prevalent styles of digest
  173. ;; out there, by converting them into rfc 934 conformant digests.
  174. ;; In this we can only be partially successful.  Such is life.
  175. (defun vm-fix-grotty-digest (start end)
  176.   (save-excursion
  177.     (save-restriction
  178.       (narrow-to-region start end)
  179.       (goto-char start)
  180.       (forward-line 1)
  181.       (while (re-search-forward "^-[^ ]" nil t)
  182.     (goto-char (match-beginning 0))
  183.     (if (not (catch 'real-separator
  184.            ;; expect reasonably long message separators
  185.            (if (not (looking-at "------------"))
  186.                (throw 'real-separator nil))
  187.            ;; expect message separators to be bracketed by blank lines
  188.            (if (/= (char-after (- (point) 2)) ?\n)
  189.                (throw 'real-separator nil))
  190.            (if (not (looking-at ".+\n\n"))
  191.                (throw 'real-separator nil))
  192.            t ))
  193.         (insert "- "))
  194.     (forward-line 1)))))
  195.